home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 4_2005-2006.ISO / data / Zips / run-length2014018172006.psc / VB Projects / Common / mSurfaceDesc.bas < prev   
BASIC Source File  |  2006-08-17  |  16KB  |  488 lines
  1. Attribute VB_Name = "mSurfaceDesc"
  2. Option Explicit
  3.  
  4. '+------------------+-----------------------------------+'
  5. '| mSurfaceDesc.bas | developed in Visual Basic 6.0     |'
  6. '+---------+--------+-----------------------------------+'
  7. '| Release | Public 0.1a August 14 2006 - 060814        |'
  8. '+---------+-------+------------------------------------+'
  9. '| Original author | dafhi                              |'
  10. '+-------------+---+------------------------------------+'
  11. '| Description | SurfaceDescriptor UDT is a wrapper for |'
  12. '+-------------+ graphics array processing.             |'
  13. '|                                                      |'
  14. '| Blit() sub uses StretchDiBits which is generally the |'
  15. '| fastest method overall for processing on arrays      |'
  16. '|                                                      |'
  17. '+--------- Dependencies ------------+                  |'
  18. '| mGeneral.bas                      |                  |'
  19. '| -> FileDlg2.cls                   |                  |'
  20. '|                                   |                  |'
  21. '+------------------------------+----+------------------+'
  22. '| Contributors / Modifications |                       |'
  23. '+------------------------------+                       |'
  24. '|                                                      |'
  25. '|                                                      |'
  26. '+------------------------------------------------------+'
  27.  
  28. ' =============== Changes & Fixes ================
  29.  
  30. ' + Renamed ScanRgns to SectDelt
  31.  
  32. ' - Aug 16, 2006 -
  33.  
  34. ' + Removed one UDT for simplification
  35. ' + Simplified RunLen_Encode and MaskBlit (should be unnoticeably faster ;)
  36.  
  37. ' - Aug 14, 2006 -
  38.  
  39. ' + Renamed CreateMaskStructure to RunLen_Encode
  40. ' + Added ability to change safearray lowbound
  41. ' in HookRGBQ_Begin Hook1D_Begin
  42.  
  43. ' ================ How to use   ==================
  44.  
  45. ' 1. CreateSurfaceDesc or SurfaceDescFromFile to initialize surface
  46.  
  47. ' 2. Blit() will blit to DC specified by MySurface.ToDC (you can set it in the initialization subs)
  48.  
  49. ' 3. Graphics write examples TestSurfaceDesc() and ColorFill()
  50.  
  51. ' 4. RunLen_Encode() will, given MaskColor > -1 (and filled image)
  52. ' create the structure necessary for the following ..
  53.  
  54. ' 5. MaskBlit() is intended for sprites, and blits from one surface
  55. ' to another
  56.  
  57. ' ...
  58.  
  59. Dim mSA1      As SAFEARRAY1D 'used from SurfaceDescToFile
  60.  
  61. Public Type StartAndFin
  62.     Start As Integer   'x or y start of run length
  63.     Delta As Integer   'delta between start and end, or length - 1
  64. End Type
  65.  
  66. Private Type MaskProc
  67.     ySegs      As Integer
  68.     not_used   As Integer
  69.     vRun()     As StartAndFin 'DeltaSE
  70.     SectDelt() As Long
  71.     hRun()     As StartAndFin
  72. End Type
  73.  
  74. Type SurfaceDescriptor
  75.     ToDC      As Long    'helpful
  76.     Wide      As Long
  77.     High      As Long
  78.     WM        As Integer 'For X = [0 To mySD.WM] or ..
  79.                          'For X = [mySD.LowX To mySD.LowX + mySD.WM]
  80.     HM        As Integer
  81.     LowX      As Integer 'lowbound
  82.     LowY      As Integer
  83.     PelCount  As Long
  84.     U1D       As Long    'helpful: ubound for safearray 1d creation
  85.     BIH       As BITMAPINFOHEADER
  86.     Dib32()   As Long
  87.     MaskInfo  As MaskProc
  88. End Type
  89.  
  90. Public gSurf  As SurfaceDescriptor
  91.  
  92.  
  93. '''''''''''''''''''''''''''
  94. '                         '
  95. '   Run-Length Blit       '
  96. '                         '
  97. '''''''''''''''''''''''''''
  98.  
  99. Public Sub RunLen_Encode(pSurf As SurfaceDescriptor, Optional ByVal MaskColor As Long = -1)
  100. Dim LX        As Integer
  101. Dim LY        As Integer
  102. Dim IsBlit    As Boolean
  103. Dim IsBlitP   As Boolean
  104. Dim ScBlit    As Boolean
  105. Dim ScBlitP   As Boolean
  106. Dim cRgn      As Long
  107. Dim BlitLenM  As Long
  108. Dim vRgnPtr   As Long
  109. Dim DimMode   As Long
  110. Dim cRgnP     As Long
  111. Dim vLen      As Long
  112. Dim ScanPtr   As Long
  113.  
  114.     'SurfaceDescFromFile or CreateSurfaceDesc first!
  115.  
  116.     If pSurf.PelCount < 1 Then Exit Sub
  117.     
  118.     For DimMode = 0 To 1
  119.     
  120.         For LY = pSurf.LowY To pSurf.LowY + pSurf.HM
  121.             BlitLenM = 0
  122.             For LX = pSurf.LowX To pSurf.LowX + pSurf.WM
  123.                 IsBlit = pSurf.Dib32(LX, LY) <> MaskColor
  124.                 If IsBlit Xor IsBlitP Then
  125.                     If IsBlit Then 'wasn't blit, now is
  126.                         If DimMode = 1 Then
  127.                             pSurf.MaskInfo.hRun(cRgn).Start = LX
  128.                         End If
  129.                     Else 'was blit, now not
  130.                         If DimMode = 1 Then
  131.                             pSurf.MaskInfo.hRun(cRgn).Delta = BlitLenM
  132.                         End If
  133.                         BlitLenM = 0
  134.                         Add cRgn, 1
  135.                     End If
  136.                 ElseIf IsBlit Then
  137.                     Add BlitLenM, 1
  138.                 End If
  139.                 IsBlitP = IsBlit
  140.             Next
  141.             IsBlitP = False
  142.             
  143.             If IsBlit Then
  144.                 If DimMode = 1 Then
  145.                     pSurf.MaskInfo.hRun(cRgn).Delta = BlitLenM
  146.                 End If
  147.                 Add cRgn, 1
  148.             End If
  149.             
  150.             ScBlit = (cRgn - cRgnP) > 0
  151.             If ScBlit Xor ScBlitP Then
  152.                 If ScBlit Then 'wasn't, now is
  153.                     Add vRgnPtr, 1
  154.                     If DimMode = 1 Then
  155.                         pSurf.MaskInfo.vRun(vRgnPtr).Start = LY
  156.                     End If
  157.                     vLen = 0
  158.                 Else 'was, now isn't
  159.                     If DimMode = 1 Then
  160.                         pSurf.MaskInfo.vRun(vRgnPtr).Delta = vLen - 1
  161.                     End If
  162.                 End If
  163.             End If
  164.             
  165.             If ScBlit Then
  166.                 If DimMode = 1 Then
  167.                     pSurf.MaskInfo.SectDelt(ScanPtr) = cRgn - 1 - cRgnP
  168.                 End If
  169.                 Add ScanPtr, 1
  170.                 cRgnP = cRgn
  171.             End If
  172.             
  173.             Add vLen, 1
  174.             ScBlitP = ScBlit
  175.         
  176.         Next
  177.          
  178.         If vRgnPtr > 0 Then
  179.             If DimMode = 0 Then
  180.                 Erase pSurf.MaskInfo.vRun
  181.                 ReDim pSurf.MaskInfo.vRun(1 To vRgnPtr)
  182.                 Erase pSurf.MaskInfo.SectDelt
  183.                 ReDim pSurf.MaskInfo.SectDelt(ScanPtr - 1)
  184.                 pSurf.MaskInfo.ySegs = vRgnPtr
  185.             ElseIf ScBlit Then
  186.                 pSurf.MaskInfo.vRun(vRgnPtr).Delta = vLen - 1
  187.                 vLen = 0
  188.             End If
  189.         End If
  190.         
  191.         If cRgn > 0 Then
  192.             If DimMode = 0 Then
  193.                 Erase pSurf.MaskInfo.hRun
  194.                 ReDim pSurf.MaskInfo.hRun(0 To cRgn - 1)
  195.             End If
  196.             cRgn = 0
  197.             cRgnP = 0
  198.         End If
  199.     
  200.         ScBlitP = False
  201.         IsBlit = False
  202.         vRgnPtr = 0
  203.         ScanPtr = 0
  204.         
  205.     Next
  206.  
  207. End Sub
  208. Public Sub MaskBlit(pDest As SurfaceDescriptor, pSrc As SurfaceDescriptor, Optional ByVal pX As Single, Optional ByVal pY As Single)
  209. Dim yPtr     As Long
  210. Dim LenRef   As Long
  211. Dim hPtrE    As Long
  212. Dim hPtrS    As Long
  213.  
  214. Dim ySrcS    As Integer
  215. Dim ySrcE    As Integer
  216. Dim xSrcS    As Integer
  217. Dim xSrcE    As Integer
  218.  
  219. Dim ySrcE2   As Integer
  220. Dim xSrcE2   As Integer
  221.  
  222. Dim lTmp__   As Integer
  223. Dim SrcBotM1 As Integer
  224.  
  225. Dim DestLeft As Integer
  226. Dim DestBot  As Integer
  227. Dim yDst     As Integer
  228. Dim ySrcEP   As Integer
  229.  
  230. Dim SrcMinY  As Integer
  231. Dim SrcMinX  As Integer
  232. Dim SrcMaxY  As Integer
  233. Dim SrcMaxX  As Integer
  234.  
  235.     'RunLen_Encode() contains the encode source
  236.     
  237.     z_GetClipRgn DestLeft, SrcMinX, SrcMaxX, pSrc.WM, pSrc.LowX, pDest.LowX, pDest.LowX + pDest.WM, pX
  238.     z_GetClipRgn DestBot, SrcMinY, SrcMaxY, pSrc.HM, pSrc.LowY, pDest.LowY, pDest.LowY + pDest.HM, pY
  239.     
  240.     SrcBotM1 = SrcMinY - 1
  241.     
  242.     For yPtr = 1 To pSrc.MaskInfo.ySegs
  243.     
  244.         'vertical contiguous chunk of scanlines that have data
  245.         ySrcS = pSrc.MaskInfo.vRun(yPtr).Start
  246.         ySrcE = ySrcS + pSrc.MaskInfo.vRun(yPtr).Delta
  247.         
  248.         'z_GetClipRgn computes MaxY, MinY, etc.
  249.         If ySrcE > SrcMaxY Then
  250.             ySrcE2 = SrcMaxY
  251.         Else
  252.             ySrcE2 = ySrcE
  253.         End If
  254.         
  255.         For ySrcS = ySrcS To ySrcE2 'vertical run length
  256.         
  257.             'with new scanline we have this recomputation
  258.             hPtrE = hPtrS + pSrc.MaskInfo.SectDelt(LenRef)
  259.             
  260.             If ySrcS > SrcBotM1 Then
  261.  
  262.                 yDst = ySrcS + DestBot
  263.                 
  264.                 For hPtrS = hPtrS To hPtrE
  265.                     
  266.                     xSrcS = pSrc.MaskInfo.hRun(hPtrS).Start
  267.                     xSrcE = xSrcS + pSrc.MaskInfo.hRun(hPtrS).Delta
  268.                     
  269.                     If xSrcS < SrcMinX Then xSrcS = SrcMinX
  270.                     
  271.                     If xSrcE > SrcMaxX Then xSrcE = SrcMaxX
  272.     
  273.                     For xSrcS = xSrcS To xSrcE
  274.                         pDest.Dib32(xSrcS + DestLeft, yDst) = pSrc.Dib32(xSrcS, ySrcS)
  275.                     Next
  276.                     
  277.                 Next
  278.             
  279.             End If
  280.             
  281.             LenRef = LenRef + 1
  282.             hPtrS = hPtrE + 1
  283.         
  284.         Next
  285.         
  286.         If ySrcE > SrcMaxY Then Exit For
  287.     
  288.     Next
  289.  
  290. End Sub
  291. Private Sub z_GetClipRgn(pDest As Integer, pSrcMin As Integer, pSrcMax As Integer, ByVal pSrcM1 As Integer, ByVal pSrcLow As Integer, ByVal pDestLow As Integer, ByVal pDestHigh As Integer, pVal As Single)
  292.  
  293.     pDest = Int(pVal + 0.5) 'round
  294.     
  295.     pSrcMax = pSrcLow + pSrcM1
  296.     
  297.     If pDest + pSrcM1 > pDestHigh Then
  298.         pSrcMax = pSrcMax - (pDest + pSrcM1 - pDestHigh)
  299.     End If
  300.     
  301.     pSrcMin = pSrcLow
  302.     If pDest < pDestLow Then
  303.         pSrcMin = pSrcMin + pDestLow - pDest
  304.     End If
  305.     
  306.     pDest = pDest - pSrcLow
  307.     
  308. End Sub
  309.  
  310.  
  311. '''''''''''''''''''''''''''
  312. '                         '
  313. '   Example array write   '
  314. '                         '
  315. '''''''''''''''''''''''''''
  316.  
  317. Sub TestSurfaceDesc(pSDESC As SurfaceDescriptor)
  318. Dim LJ As Long, lI As Long
  319.  
  320.     If pSDESC.PelCount < 1 Then Exit Sub
  321.  
  322.     For LJ = pSDESC.LowY To pSDESC.LowY + pSDESC.HM
  323.         For lI = pSDESC.LowX To pSDESC.LowX + pSDESC.WM
  324.             pSDESC.Dib32(lI, LJ) = ARGBHSV(255, Rnd, Rnd * 255)
  325.         Next
  326.     Next
  327.     
  328.     Blit pSDESC
  329.     
  330. End Sub
  331.  
  332. Public Sub ColorFill(Surf As SurfaceDescriptor, pAry() As Long, pSA As SAFEARRAY1D, Optional ByVal pColor As Long = 0, Optional ByVal pLowBound As Long = 0)
  333. Dim L1 As Long
  334.  
  335.     'how to use hook subs
  336.     
  337.     Hook1D_Begin Surf, pAry, pSA, pLowBound
  338.     
  339.     For L1 = pLowBound To pLowBound + Surf.U1D
  340.         pAry(L1) = pColor 'now have 1d access!
  341.     Next
  342.     
  343.     Hook1D_End pAry
  344.  
  345. End Sub
  346.  
  347.  
  348. '''''''''''''''''''''''''''
  349. '                         '
  350. '   Blit                  '
  351. '                         '
  352. '''''''''''''''''''''''''''
  353.  
  354. Sub Blit(pSD As SurfaceDescriptor, Optional ByVal pX As Integer, Optional ByVal pY As Integer, Optional ByVal pWid As Integer = -1, Optional ByVal pHgt As Integer = -1)
  355.  
  356.     If pSD.PelCount < 1 Then Exit Sub
  357.  
  358.     If pWid < 0 Then pWid = pSD.Wide
  359.     If pHgt < 0 Then pHgt = pSD.High
  360.     
  361.     StretchDIBits pSD.ToDC, _
  362.       pX, pY, pWid, pHgt, _
  363.       0, 0, pSD.Wide, pSD.High, _
  364.       pSD.Dib32(pSD.LowX, pSD.LowY), pSD.BIH, DIB_RGB_COLORS, vbSrcCopy
  365.  
  366. End Sub
  367.  
  368.  
  369. '''''''''''''''''''''''''''
  370. '                         '
  371. '   Create Surface        '
  372. '                         '
  373. '''''''''''''''''''''''''''
  374.  
  375. Sub CreateSurfaceDesc(SDesc1 As SurfaceDescriptor, lHDC As Long, ByVal Wide As Long, ByVal High As Long, Optional ByVal LowX As Integer = 0, Optional ByVal LowY As Integer = 0)
  376.  
  377.     'Example: CreateSurfaceDesc mySD, mySD.Dib32, Picture1.hDC, 640, 480, 1, 1
  378.  
  379.     If Wide = SDesc1.Wide And High = SDesc1.High Then Exit Sub
  380.     If Wide * High < 1 Or Wide * High > 10000000 Then Exit Sub
  381.     SDesc1.PelCount = Wide * High
  382.     SDesc1.U1D = SDesc1.PelCount - 1
  383.     SDesc1.ToDC = lHDC
  384.     SDesc1.High = High
  385.     SDesc1.Wide = Wide
  386.     SDesc1.WM = SDesc1.Wide - 1
  387.     SDesc1.HM = SDesc1.High - 1
  388.     SDesc1.LowX = LowX
  389.     SDesc1.LowY = LowY
  390.     SDesc1.BIH.biHeight = High
  391.     SDesc1.BIH.biWidth = Wide
  392.     SDesc1.BIH.biPlanes = 1
  393.     SDesc1.BIH.biBitCount = 32
  394.     SDesc1.BIH.biSize = Len(SDesc1.BIH)
  395.     SDesc1.BIH.biSizeImage = 4 * SDesc1.PelCount
  396.     SDesc1.BIH.biCompression = BI_RGB
  397.     Erase SDesc1.Dib32
  398.     ReDim SDesc1.Dib32(LowX To LowX + SDesc1.WM, LowY To LowY + SDesc1.HM)
  399.  
  400. End Sub
  401.  
  402. Public Sub Surface_OnResize(pSurf As SurfaceDescriptor, pPic As Picture, Optional pDC As Long)
  403.     If pPic.Height < 1 Or pPic.Width < 1 Then Exit Sub
  404.     CreateSurfaceDesc pSurf, pDC, pPic.Width, pPic.Height
  405. End Sub
  406.  
  407.  
  408. '''''''''''''''''''''''''''
  409. '                         '
  410. '   Load                  '
  411. '                         '
  412. '''''''''''''''''''''''''''
  413.  
  414. Public Function SurfaceDescFromFile(Surf As SurfaceDescriptor, strFileName$, Optional ByVal pHDC As Long, Optional ByVal MaskColor As Long = -1, Optional ByVal pLowX As Integer = 0, Optional ByVal pLowY As Integer = 0, Optional ByVal StrFolder$ = "") As String
  415. Dim tBM As Bitmap
  416. Dim CDC&, lStrFile As String, tBI As BITMAPINFO
  417. Dim lStrFileFolder As String
  418. Dim L1 As Long
  419.  
  420. Dim ThePic As StdPicture
  421.    
  422.    z_SurfaceDescFileCommon lStrFileFolder, StrFolder, lStrFile, strFileName
  423.  
  424.    On Local Error GoTo FileError
  425.    Set ThePic = LoadPicture(lStrFile) 'this will crash with invalid pictures
  426.    
  427.    If GetObject(ThePic, Len(tBM), tBM) = 0 Then
  428.       Set ThePic = Nothing
  429.       MsgBox "FILE ERROR"
  430.       Exit Function
  431.    End If
  432.  
  433.    CreateSurfaceDesc Surf, pHDC, tBM.bmWidth, tBM.bmHeight, pLowX, pLowY
  434.     
  435.    CDC = CreateCompatibleDC(0)           ' Temporary device
  436.  
  437.    DeleteObject SelectObject(CDC, ThePic)  ' Converted bitmap
  438.    
  439.    tBI.bmiHeader.biSize = 40
  440.    Call GetDIBits(CDC, ThePic.Handle, 0, 0, ByVal 0&, tBI, 0)
  441.    tBI.bmiHeader.biBitCount = 32
  442.    
  443.    L1 = GetDIBits(CDC, ThePic.Handle, 0, Surf.High, Surf.Dib32(pLowX, pLowY), tBI, 0)
  444.    
  445.    If MaskColor > -1 Then
  446.        RunLen_Encode Surf, MaskColor
  447.    End If
  448.    
  449.    DeleteDC CDC
  450.    Set ThePic = Nothing
  451.    
  452.    If L1 = 0 Then
  453.       MsgBox "DIB ERROR"
  454.       Exit Function
  455.    End If
  456.  
  457.     SurfaceDescFromFile = "Success!"
  458.    Exit Function
  459.     
  460. FileError:
  461.       MsgBox "FILE ERROR"
  462.  
  463. End Function
  464. Public Function FileToSurfaceDesc(Surf As SurfaceDescriptor, strFileName$, Optional ByVal pHDC As Long, Optional ByVal MaskColor As Long = -1, Optional ByVal pLowX As Integer = 0, Optional ByVal pLowY As Integer = 0, Optional ByVal StrFolder$ = "") As String
  465.     FileToSurfaceDesc = SurfaceDescFromFile(Surf, strFileName, pHDC, MaskColor, pLowX, pLowY, StrFolder)
  466. End Function
  467.  
  468.  
  469. '''''''''''''''''''''''''''
  470. '                         '
  471. '   Save                  '
  472. '                         '
  473. '''''''''''''''''''''''''''
  474.  
  475. Public Function SurfaceDescToFile(Surf As SurfaceDescriptor, strFileName$, Optional ByVal StrFolder$ = "") As String
  476. Dim tBMF As BitmapFileHeader
  477. Dim lStrFile As String, tBIH As BITMAPINFOHEADER
  478. Dim lStrFileFolder As String
  479. Dim L1 As Long, L2 As Long, L3 As Long, FFile As Integer
  480. Dim PadBytes As Long, Bytes() As Byte
  481. Dim tRGBQ() As RGBQUA.pyVal Mst|kGBQ() Aeger, ByVal  BQ() Ae"
  482.    Exit FunctHeadyErB Aeger, ByVizeeady=eadys,u String
  483. D|pAe"nteger
  484. DimeaceDesleeFold0ith invalid pith inv = "") As     Lu S File(Surf,d0ith,d0ith,d0itSrcS = ySrcS To HR AsSurf,d0ith,d06ith,dB Aege "") 0t,d0ith,d0il yI'R AsS,d0il FFByVal MaskColor Eauring, tBIH As BITMAPIN
  485. DimeaMbal Mas'tor, strFileNam
  486.    On nStNothix - (pDest +  sgBox "FILE ERRO As Long, 'Vder.biBitCount =     tBM.bmWepSrcM1 As Inte' ITMAPIN
  487. DimeaMbal Mas'tor,!     As IntWidth, pPififsiubl =     tBM.bLE Ecsu S FilefDim tLu S______trlRb4trFileFolderColor, pLowXleb4trMAPIN
  488. DimeaMbal Mas't, OerColopg, ttttttttttpYrMA      eSacoaMbal Mas't, OerColr, pLowXly ERROR0ee5iAs 5iAs 5iAAAABQ() As RGBQUA.Dim iAs 5iAAAABQ() As RGBlRb4trFileFGal Mst    Len.bmWen.bmWen l&a) As RGBlRbtLow T&rEEEEEEEEEEEn.bmWen l&a) AsbpEEEEE0dAs Struager      >EEEth,dtAong_uager      >EEEgD    seateSun l&a) Asbring,M1 As at =     L  >EEE  SD3rColor, b T&rEEEEEEEEEEEnat t:e, tBI      ScanPtr I      ScanPtr   As n0dAs SSSSSn0dAsea ScanPiBitCorpmhO StringSPScanPiBitrn n0dAsinSn0dAsea  l                eateSu=      1